home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Thomas / run-internal.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  4.7 KB  |  123 lines  |  [TEXT/gamI]
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;* 
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;* 
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;* 
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: runtime-internal.scm,v 1.9 1992/09/20 08:20:20 birkholz Exp $
  39.  
  40. ;;;; This file contains the functions that are referenced only
  41. ;;;; directly by the output of the Dylan to Scheme compiler, rather
  42. ;;;; than user code written in Dylan.
  43. ;;;;
  44. ;;;; Many of the functions here are just renamings of ordinary Scheme
  45. ;;;; functions.  The renaming is necessary to prevent name clashes
  46. ;;;; between Dylan and Scheme variables at run time.
  47.  
  48. (define (dylan::free-variable-ref value name)
  49.   (if (eq? value the-unassigned-value)
  50.       (dylan-call dylan:error "unbound variable" name)
  51.       value))
  52.  
  53. (define dylan::call/cc            ; Used for BIND-EXIT
  54.   call-with-current-continuation)
  55.  
  56. (define (dylan::dotimes count result-fn fn)
  57.   ;; Used for DOTIMES special form
  58.   (let loop ((n 0))
  59.     (if (>= n count)
  60.     (result-fn)
  61.     (begin
  62.       (fn n)
  63.       (loop (+ n 1))))))
  64.  
  65. (define (dylan::while test thunk)
  66.   ;; Used for UNTIL and WHILE special forms
  67.   (let loop ()
  68.     (if (test)
  69.     (begin (thunk) (loop))
  70.     #F)))
  71.  
  72. (define (dylan::apply multiple-values? operator-thunk . operand-thunks)
  73.   ;; Used for combinations.
  74.   ;; Forces left-to-right evaluation, and adds an initial #F next
  75.   ;; method argument.
  76.   (let loop ((rands '())
  77.          (rest operand-thunks))
  78.     (if (null? rest)
  79.     (apply (operator-thunk)
  80.            multiple-values?
  81.            NEXT-METHOD:NOT-GENERIC
  82.            (reverse rands))
  83.     (let ((next ((car rest))))
  84.       (loop (cons next rands) (cdr rest))))))
  85.  
  86. (define dylan::scheme-apply apply)
  87.  
  88. (define dylan::dynamic-wind        ; Used for UNWIND-PROTECT
  89.   dynamic-wind)
  90.  
  91. (define (dylan::type-check value class) ; Used for BIND
  92. ;  (let ((type-of-object (get-type value)))
  93. ;    (if (not (subclass? type-of-object class))
  94. ;    (dylan-call dylan:error
  95. ;            "BINDing-time restriction violation" class value)))
  96.   ;; Should signal a <type-error>!
  97.   (dylan-call dylan:check-type value class))
  98.  
  99. (define dylan::list list)        ; BIND
  100. (define dylan::cons cons)        ; BIND
  101. (define dylan::car car)            ; BIND
  102. (define dylan::vector vector)        ; BIND
  103. (define dylan::vector-ref vector-ref)    ; BIND
  104. (define dylan::not not)            ; DEFINE-GENERIC-FUNCTION, UNLESS
  105. (define dylan::eq? eq?)            ; DEFINE-GENERIC-FUNCTION
  106. (define dylan::class? class?)        ; DEFINE-CLASS
  107. (define dylan::make-param-list        ; METHOD
  108.   make-param-list)
  109. (define dylan::add-method add-method)    ; DEFINE-METHOD
  110. (define dylan::null? null?)        ; COND
  111.  
  112. (define (dylan::for-each fn . collections)
  113.   (for-each
  114.    (lambda (collection)
  115.      (if (not (subclass? (get-type collection) <collection>))
  116.      (dylan-call dylan:error "for-each -- not a collection" collection)))
  117.    collections)
  118.   (collections-iterate fn
  119.                (lambda (result)
  120.              (and result (lambda () (car result))))
  121.                #F
  122.                collections))
  123.